home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLSUBR.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-10-05  |  4.5 KB  |  216 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *k_test,*k_tnot,*s_eql;
  10. extern NODE ***xlstack;
  11.  
  12. /* xlsubr - define a builtin function */
  13. xlsubr(sname,type,subr)
  14.   char *sname; int type; NODE *(*subr)();
  15. {
  16.     NODE *sym;
  17.  
  18.     /* enter the symbol */
  19.     sym = xlsenter(sname);
  20.  
  21.     /* initialize the value */
  22.     setvalue(sym,cvsubr(subr,type));
  23. }
  24.  
  25. /* xlarg - get the next argument */
  26. NODE *xlarg(pargs)
  27.   NODE **pargs;
  28. {
  29.     NODE *arg;
  30.  
  31.     /* make sure the argument exists */
  32.     if (!consp(*pargs))
  33.     xlfail("too few arguments");
  34.  
  35.     /* get the argument value */
  36.     arg = car(*pargs);
  37.  
  38.     /* move the argument pointer ahead */
  39.     *pargs = cdr(*pargs);
  40.  
  41.     /* return the argument */
  42.     return (arg);
  43. }
  44.  
  45. /* xlmatch - get an argument and match its type */
  46. NODE *xlmatch(type,pargs)
  47.   int type; NODE **pargs;
  48. {
  49.     NODE *arg;
  50.  
  51.     /* get the argument */
  52.     arg = xlarg(pargs);
  53.  
  54.     /* check its type */
  55.     if (type == LIST) {
  56.     if (arg && ntype(arg) != LIST)
  57.         xlerror("bad argument type",arg);
  58.     }
  59.     else {
  60.     if (arg == NIL || ntype(arg) != type)
  61.         xlerror("bad argument type",arg);
  62.     }
  63.  
  64.     /* return the argument */
  65.     return (arg);
  66. }
  67.  
  68. /* xlevarg - get the next argument and evaluate it */
  69. NODE *xlevarg(pargs)
  70.   NODE **pargs;
  71. {
  72.     NODE ***oldstk,*val;
  73.  
  74.     /* create a new stack frame */
  75.     oldstk = xlsave(&val,NULL);
  76.  
  77.     /* get the argument */
  78.     val = xlarg(pargs);
  79.  
  80.     /* evaluate the argument */
  81.     val = xleval(val);
  82.  
  83.     /* restore the previous stack frame */
  84.     xlstack = oldstk;
  85.  
  86.     /* return the argument */
  87.     return (val);
  88. }
  89.  
  90. /* xlevmatch - get an evaluated argument and match its type */
  91. NODE *xlevmatch(type,pargs)
  92.   int type; NODE **pargs;
  93. {
  94.     NODE *arg;
  95.  
  96.     /* get the argument */
  97.     arg = xlevarg(pargs);
  98.  
  99.     /* check its type */
  100.     if (type == LIST) {
  101.     if (arg && ntype(arg) != LIST)
  102.         xlerror("bad argument type",arg);
  103.     }
  104.     else {
  105.     if (arg == NIL || ntype(arg) != type)
  106.         xlerror("bad argument type",arg);
  107.     }
  108.  
  109.     /* return the argument */
  110.     return (arg);
  111. }
  112.  
  113. /* xltest - get the :test or :test-not keyword argument */
  114. xltest(pfcn,ptresult,pargs)
  115.   NODE **pfcn; int *ptresult; NODE **pargs;
  116. {
  117.     NODE *arg;
  118.  
  119.     /* default the argument to eql */
  120.     if (!consp(*pargs)) {
  121.     *pfcn = getvalue(s_eql);
  122.     *ptresult = TRUE;
  123.     return;
  124.     }
  125.  
  126.     /* get the keyword */
  127.     arg = car(*pargs);
  128.  
  129.     /* check the keyword */
  130.     if (arg == k_test)
  131.     *ptresult = TRUE;
  132.     else if (arg == k_tnot)
  133.     *ptresult = FALSE;
  134.     else
  135.     xlfail("expecting :test or :test-not");
  136.  
  137.     /* move the argument pointer ahead */
  138.     *pargs = cdr(*pargs);
  139.  
  140.     /* make sure the argument exists */
  141.     if (!consp(*pargs))
  142.     xlfail("no value for keyword argument");
  143.  
  144.     /* get the argument value */
  145.     *pfcn = car(*pargs);
  146.  
  147.     /* if its a symbol, get its value */
  148.     if (symbolp(*pfcn))
  149.     *pfcn = xleval(*pfcn);
  150.  
  151.     /* move the argument pointer ahead */
  152.     *pargs = cdr(*pargs);
  153. }
  154.  
  155. /* xlgetfile - get a file or stream */
  156. NODE *xlgetfile(pargs)
  157.   NODE **pargs;
  158. {
  159.     NODE *arg;
  160.  
  161.     /* get a file or stream (cons) or nil */
  162.     if (arg = xlarg(pargs)) {
  163.     if (filep(arg)) {
  164.         if (arg->n_fp == NULL)
  165.         xlfail("file not open");
  166.     }
  167.     else if (!consp(arg))
  168.         xlerror("bad argument type",arg);
  169.     }
  170.     return (arg);
  171. }
  172.  
  173. /* xllastarg - make sure the remainder of the argument list is empty */
  174. xllastarg(args)
  175.   NODE *args;
  176. {
  177.     if (args)
  178.     xlfail("too many arguments");
  179. }
  180.  
  181. /* eq - internal eq function */
  182. int eq(arg1,arg2)
  183.   NODE *arg1,*arg2;
  184. {
  185.     return (arg1 == arg2);
  186. }
  187.  
  188. /* eql - internal eql function */
  189. int eql(arg1,arg2)
  190.   NODE *arg1,*arg2;
  191. {
  192.     if (eq(arg1,arg2))
  193.     return (TRUE);
  194.     else if (fixp(arg1) && fixp(arg2))
  195.     return (arg1->n_int == arg2->n_int);
  196.     else if (floatp(arg1) && floatp(arg2))
  197.     return (arg1->n_float == arg2->n_float);
  198.     else if (stringp(arg1) && stringp(arg2))
  199.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  200.     else
  201.     return (FALSE);
  202. }
  203.  
  204. /* equal - internal equal function */
  205. int equal(arg1,arg2)
  206.   NODE *arg1,*arg2;
  207. {
  208.     /* compare the arguments */
  209.     if (eql(arg1,arg2))
  210.     return (TRUE);
  211.     else if (consp(arg1) && consp(arg2))
  212.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  213.     else
  214.     return (FALSE);
  215. }
  216.